home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / prog / prot100.zip / FOS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-15  |  13KB  |  517 lines
  1. (*
  2.     FOS.PAS - Communications subroutines for the ibm pc
  3.     Fossil.pas (12/24/91)
  4.     Modified Send() to use with Sealink.  Sends CHAR not byte.
  5.  
  6. FUNCTION  Com_Baud          - Returns baudrate of connection. (getfosinfo 1st)
  7. FUNCTION  Carrier           - Returns status of Carrier on PortNumber.
  8. FUNCTION  CK                - Returns status if user hit Ctrl-C/Ctrl-K.
  9. PROCEDURE CloseFossil       - Terminates output to the Fossil.
  10. FUNCTION  Com_              - General Purpose Comm function.
  11. FUNCTION  Com_Data          - Returns data bits (getfosinfo 1st)
  12. FUNCTION  Com_Parity        - Returns Parity as char (N,E,O) (getfosinfo 1st)
  13. FUNCTION  Com_Stop          - Returns stop bits (getfosinfo 1st)
  14. PROCEDURE Comm_Set_Baud     - Set Baud, Parity, Data Bits, Stop Bits.
  15. FUNCTION  Comm_Transmit     - Returns STATUS bits of a transmit with wait.
  16. PROCEDURE FlushBuff         - Flush Outbound buffer (fossil).
  17. PROCEDURE FlowControl       - Establish flow control.
  18. FUNCTION  FPresent          - Checks if Fossil installed (no init).
  19. PROCEDURE GetFosInfo        - Fills the FosInfo structure variable.
  20. PROCEDURE HangUpPhone       - Hangs up the telephone - fossil.
  21. FUNCTION  KeyChar           - Checks if char is available from keyboard.
  22. PROCEDURE ModemPut          - Sends commands to the modem.  Like BINKLEYTERM
  23. FUNCTION  OpenFossil        - Checks to see if Fossil installed.
  24. FUNCTION  OutEmpty          - Returns TRUE if output buffer is empty.
  25. PROCEDURE PurgeLine         - Purge the receive buffer.
  26. PROCEDURE PurgeOutput       - Purges the output (transmit) buffer.
  27. PROCEDURE ReadBlk           - Reads a block from the communications port.
  28. FUNCTION  ReadLine          - Return ORD of char received or TIMEOUT.
  29. FUNCTION  Receive           - Fossil receive a character.
  30. PROCEDURE Send              - Fossil transfer a character.
  31. PROCEDURE SendBlk           - Send a block of chars through port.
  32. PROCEDURE SendText          - Sends a string to the modem
  33. FUNCTION  SerialChar        - Checks if char is available from PortNum.
  34. PROCEDURE SetBaudRate       - Change baud rate of communications port. N-8-1
  35. PROCEDURE SetCheck          - Turns Ctrl-C/Ctrl-K checking on/off.
  36. PROCEDURE SetDTR            - Toggles status of DTR.
  37. *)
  38.  
  39. UNIT Fos;
  40.  
  41. interface
  42.  
  43. type  FosData = record
  44.          ssize    : word;
  45.          version  : byte;
  46.          revision : byte;
  47.          segment  : word;  { id : longint }
  48.          offset   : word;
  49.          rcvbuf   : word;
  50.          i_avail  : word;
  51.          sndbuf   : word;
  52.          o_avail  : word;
  53.          width    : byte;
  54.          height   : byte;
  55.          baud     : byte;
  56.       end;
  57.  
  58. const loopspersec = 6500;
  59.       timeout  = 256;
  60.  
  61. var PortNum : word;
  62.     BaudRate: word;
  63.     Parity  : Char;
  64.     DataBits: Byte;
  65.     StopBits: Byte;
  66.     FosInfo : FosData;
  67.     FossilIDStr : string;
  68.  
  69. function  carrier : boolean;
  70. function  ck : boolean;
  71. procedure closefossil;
  72. function  com_baud(baud:byte) : word;
  73. function  com_data(baud:byte):byte;
  74. function  com_parity(baud:byte):char;
  75. function  com_stop(baud:byte):byte;
  76. procedure comm_set_baud( baud:word; parity : char; data, stop : byte);
  77. procedure flushbuff;
  78. procedure flowcontrol(kind:byte);
  79. function  fpresent : boolean;
  80. procedure getfosinfo( var fosinfo : fosdata);
  81. procedure hangupphone;
  82. function  keychar : boolean;
  83. procedure modemput(initstr:string);
  84. function  openfossil : boolean;
  85. function  outempty : boolean;
  86. procedure purgeline;
  87. procedure purgeoutput;
  88. procedure readblk(segment,offset,count:word);
  89. function  readline(seconds:integer): integer;
  90. function  receive : char;
  91. procedure send(letter : char);
  92. procedure setbaudrate ( baud : word);
  93. procedure setcheck( on : boolean);
  94. procedure setdtr( a : boolean);
  95. function  serialchar : boolean;
  96. procedure sendtext(initstr : string);
  97. procedure sendblk( Seg_Ment, Off_Set, count:word);
  98.  
  99. implementation
  100.  
  101. uses crt,
  102.      dos;
  103.  
  104. type
  105.     ptrmask = record   { segment:offset mask for address pointers }
  106.        poff : word;
  107.        pseg : word;
  108.     end;
  109.  
  110. var regs : registers;
  111.  
  112. {---------------------------- ASCIIZ to string ----------------------------}
  113. function Asc2Str(var s; max: byte): string;
  114. { Converts an ASCIIZ string to a Turbo Pascal string with a max length: max. }
  115. var starray  : array[1..255] of char absolute s;
  116.     len      : integer;
  117. begin
  118.      len        := pos(#0,starray)-1;                       { Get the length }
  119.      if (len > max) or (len < 0) then               { length exceeds maximum }
  120.        len      := max;                                  { so set to maximum }
  121.      Asc2Str    := starray;
  122.      Asc2Str[0] := chr(len);                                    { Set length }
  123. end;  { Asc2Str }
  124.  
  125. function com_baud(baud:byte):word;
  126. begin
  127.   baud := baud shr 5;
  128.   case baud of
  129.     $02 : com_baud :=   300;
  130.     $03 : com_baud :=   600;
  131.     $04 : com_baud :=  1200;
  132.     $05 : com_baud :=  2400;
  133.     $06 : com_baud :=  4800;
  134.     $07 : com_baud :=  9600;
  135.     $00 : com_baud := 19200;
  136.     $01 : com_baud := 38400;
  137.   else
  138.     com_baud := 1200;
  139.   end;
  140. end;
  141.  
  142.  
  143. function fpresent : boolean;             (* FOSSIL there? *)
  144. Var Int14Vec : Pointer;
  145. begin
  146.   GetIntVec($14, Int14Vec);
  147.   FPresent := (MemW[Seg(Int14Vec^):Ofs(Int14Vec^) + 6] = $1954);
  148. end;
  149.  
  150.  
  151. function openfossil : boolean;
  152. begin
  153.   regs.ah := $04;
  154.   regs.dx := PortNum;
  155.   Intr($14,regs); { TPX00( regs) ; }
  156.   OpenFossil := (Regs.AX = $1954);
  157. end;
  158.  
  159.  
  160. function ck : boolean;
  161. begin
  162.    ck := FALSE;
  163.    if keypressed then
  164.       ck := (readkey in [#3,#11])
  165.    else if serialchar then ck := (receive in [#3,#11]);
  166. end;
  167.  
  168.  
  169. procedure closefossil;
  170. begin
  171.   asm
  172.      mov ah, 5
  173.      mov dx, portnum
  174.      int 14h
  175.   end;
  176. end;
  177.  
  178.  
  179. function com_data(baud:byte):byte; { pass it: FossInfo.baud }
  180. var p : boolean;
  181. begin
  182.     p := (baud and $03) = $03;
  183.     if p then com_data := 8 else com_data := 7;
  184. end;
  185.  
  186.  
  187. function com_parity(baud:byte):char; { pass it: FossInfo.baud }
  188. var p : boolean;
  189. begin
  190.     p := (baud and $18) = $18;
  191.     if p then com_parity := 'E' else begin
  192.        p := (baud and $08) = $08;
  193.        if p then com_parity := 'O' else com_parity := 'N';
  194.     end;
  195. end;
  196.  
  197.  
  198. function com_stop(baud:byte):byte; { pass it: FossInfo.baud }
  199. begin
  200.   com_stop := (baud and $04) + 1;
  201. end;
  202.  
  203.  
  204. procedure comm_set_baud( baud : word; parity : char; data, stop : byte);
  205. var value : byte;
  206. begin
  207.    Regs.AH := 0;
  208.    Regs.DX := PortNum;
  209.    value := $60;
  210.    case baud of
  211.        300 : value:=$40;
  212.        600 : value:=$60;
  213.       1200 : value:=$80;
  214.       2400 : value:=$A0;
  215.       4800 : value:=$C0;
  216.       9600 : value:=$E0;
  217.      19200 : value:=$00;
  218.      38400 : value:=$20;
  219.    end;
  220.    case upcase(parity) of
  221.    {  'N': value := value OR $10; }
  222.      'E': value := value + $18;
  223.      'O': value := value + $08;
  224.    end;
  225.    case data of
  226.      7 : value := value + $02;
  227.      8 : value := value + $03;
  228.    end;
  229.    case stop of
  230.      2 : value := value + $04;
  231.    end;
  232.    regs.al := value;
  233.    Intr($14,regs);
  234. end;
  235.  
  236.  
  237. procedure flowcontrol(kind:byte);
  238. {
  239. call must be 'intelligent', ie. you know what you want.
  240. things are additive.  bits set  0 - enable remote restraint via xon/xoff
  241.                                 1 - cts/rts
  242.                                 2 - fossil can restrain remote via xon/xoff
  243. }
  244. begin
  245.    asm
  246.      mov AH, 0FH        { Enable/Disable ComPort Flow Control }
  247.      mov AL, kind       { Type of flow control as above       }
  248.      mov DX, Portnum
  249.      int 14H
  250.    end;
  251. end;
  252.  
  253.  
  254. procedure setbaudrate ( baud : word); { issues N-8-1 }
  255. begin
  256.    case baud of
  257.        300 : Regs.AL:=$43;
  258.        600 : Regs.AL:=$63;
  259.       1200 : Regs.AL:=$83;
  260.       2400 : Regs.AL:=$A3;
  261.       4800 : Regs.AL:=$C3;
  262.       9600 : Regs.AL:=$E3;
  263.      19200 : Regs.AL:=$03;
  264.      38400 : Regs.AL:=$23;
  265.    else
  266.       regs.al := $63;
  267.    end;
  268.    regs.ah := $00;
  269.    regs.dx := Portnum;
  270.    Intr($14, regs);
  271. end;
  272.  
  273.  
  274. function carrier : boolean;
  275. begin
  276. asm
  277.       mov  dx, PortNum
  278.       mov  ah, 3
  279.       int  14H
  280.       xor  dl, dl
  281.       and  al, 80H
  282.       jz   @2
  283.       inc  dl
  284. @2:   mov  @Result, DL
  285. end;
  286. end;
  287.  
  288.  
  289. function keychar : boolean;
  290. begin
  291.   asm
  292.        mov  ah, 0DH
  293.        mov  dx, Portnum
  294.        int  14H
  295.        xor  dl, dl
  296.        inc  ax
  297.        jz   @1
  298.        mov  dl, 1
  299.   @1:  mov @Result, dl
  300.   end;
  301. end;
  302.  
  303.  
  304. procedure setdtr( A : Boolean); assembler;
  305. asm
  306.      mov ah, 6
  307.      mov dx, Portnum
  308.      mov al, a
  309.      int 14H
  310. end;
  311.  
  312.  
  313. function serialchar : boolean;
  314. begin
  315.    asm
  316.        mov  dx, Portnum
  317.        mov  ah, 0CH
  318.        int  14H          { $FF if no characters }
  319.        xor  dl, dl
  320.        inc  ax
  321.        jz   @l1          { would be zero if no characters here }
  322.        inc  dl           { There is one! }
  323.   @l1: mov  @Result, DL
  324.   end;
  325. end;
  326.  
  327.  
  328. function receive : char;
  329. begin
  330.    asm
  331.       mov ah, 2
  332.       mov dx, Portnum
  333.       int 14H
  334.       mov @result, al
  335.    end;
  336. end;
  337.  
  338.  
  339. function outempty : boolean;
  340. begin
  341. asm
  342.      mov  ah, 3
  343.      mov  dx, PortNum
  344.      int  14H
  345.      xor  dl, dl
  346.      and  ah, 40H
  347.      jz   @l1
  348.      inc  dl
  349. @l1: mov  @Result, DL
  350. end;
  351. end;
  352.  
  353.  
  354. procedure send(Letter : char);
  355. Begin
  356.   while not outempty do;
  357.   asm
  358.        mov AH, 01H
  359.        mov AL, Letter
  360.        mov dx, PortNum
  361.        int 14H
  362.   end;
  363. end;
  364.  
  365.  
  366. procedure flushbuff; assembler;
  367. asm
  368.    mov ah, 8
  369.    mov dx, portnum
  370.    int 14h
  371. end;
  372.  
  373.  
  374. procedure getfosinfo( var fosinfo : fosdata);
  375. { Must issue call to OpenFossil before running this procedure.}
  376. var  p    : ^byte;
  377.      s    : string;
  378. begin
  379.    regs.ah := $1B;
  380.    regs.cx := SizeOf(fosinfo);
  381.    regs.es := Seg(fosinfo);
  382.    regs.di := Ofs(fosinfo);
  383.    regs.dx := PortNum;
  384.    intr($14,regs);
  385.    p := ptr(fosinfo.offset,fosinfo.segment);
  386.    s := Asc2Str(p^ , 255);
  387.    FossilIdStr := s;
  388. end;
  389.  
  390.  
  391. procedure modemput( initstr : String); { send a command to modem }
  392. var i: integer;
  393. begin
  394.   for i := 1 to length(initstr) do begin
  395.     case initstr[i] of
  396.       '-' : begin end;      { Hyphen        Stripped            }
  397.       '.' : send(',');      { Period        Translated to Comma }
  398.       '^' : setdtr(TRUE);   { Carat         Raise DTR Line      }
  399.       '`' : delay(50);      { Accent Mark   1/20th Second Delay }
  400.       'v' : setdtr(FALSE);  { Lower Case V  Lower DTR Line      }
  401.       '|' : send(#13);       { Pipe,Bar      Carriage Return Sent}
  402.       '~' : delay(1000);    { Tilde         1 Second Delay      }
  403.     else Send(initstr[i]);
  404.     end; { case }
  405.     delay(10);
  406.   end; { for }
  407.   {FlushBuff;}
  408.   Delay(500);
  409. end;
  410.  
  411.  
  412. function readline(seconds:integer): integer;
  413. var j : integer;
  414. begin
  415.     j := loopspersec * seconds;
  416.     repeat
  417.       dec(j)
  418.     until SerialChar OR (j = 0);
  419.     IF j = 0 THEN
  420.        READLINE := timeout
  421.     ELSE READLINE := ORD(Receive);
  422. end;
  423.  
  424.  
  425. procedure purgeline; assembler;
  426. asm
  427.     mov ah, 0aH
  428.     mov dx, Portnum
  429.     Int 14H
  430. end;
  431.  
  432.  
  433. procedure purgeoutput; assembler;
  434. asm
  435.    mov ah, 9
  436.    mov dx, PortNum
  437.    int 14H
  438. end;
  439.  
  440.  
  441. procedure setcheck( on : boolean); assembler;
  442. asm
  443.     mov ah,  10H
  444.     mov dx,  Portnum
  445.     mov al,  on
  446.     int 14H
  447. end;
  448.  
  449.  
  450. procedure sendtext(initstr: string);
  451. var i: integer;
  452. begin
  453.    for i := 1 to ord(initstr[0]) DO send(initstr[i]);
  454. end;
  455.  
  456.  
  457. procedure hangupphone;
  458. var i : integer;
  459.     regs : Registers;
  460. begin
  461.   setdtr(false);
  462.   delay(1000);
  463.   repeat
  464.      delay(500);
  465.      inc(i);
  466.   until (not carrier) OR (i >= 5);
  467.   if carrier then write(#07+#07+#07+#07,'*Hangup Manually*');
  468.   setdtr(true);
  469. end;
  470.  
  471.  
  472. PROCEDURE SendBlk(Seg_Ment, Off_Set, count : word);
  473. begin
  474. (*
  475.    regs.es := seg_ment;
  476.    while (count > 0) do
  477.    begin
  478.       regs.ah := $19;
  479.       regs.di := off_set;
  480.       regs.cx := count;
  481.       regs.dx := PortNum;
  482.       intr($14,regs);
  483.       count := count - regs.ax;
  484.       off_set := off_set + regs.ax;
  485.    end;
  486. *)
  487. asm
  488.       mov ES, Seg_Ment
  489.  @1:  mov CX, Count
  490.       mov AH, 19H
  491.       mov DI, Off_Set
  492.       mov DX, PortNum
  493.       int 14H
  494.       sub Count, AX
  495.       add Off_Set, AX
  496.       cmp Count, 0
  497.       jnz @1
  498. end;
  499. end;
  500.  
  501.  
  502. PROCEDURE ReadBlk(segment,offset,count : word );
  503. begin
  504.    regs.es := segment;
  505.    while (count > 0) do begin
  506.       regs.ah := $18;
  507.       regs.di := offset;
  508.       regs.cx := count;
  509.       regs.dx := PortNum;
  510.       intr($14,regs);
  511.       count := count - regs.ax;            { # of chars to go }
  512.       offset := offset + regs.ax;
  513.    end;
  514. end;
  515.  
  516. end.
  517.